(defmacro defop (func op op-symbl ident zero-case) 
  (let ((e1 (gensym "E1")) 
         (e2 (gensym "E2"))) 
     `(defun ,func (,e1 ,e2) 
       (declare (optimize (speed 3))) 
        ,(delete :no-case 
          `(case ,e1 
            ,zero-case 
            (,ident ,e2) 
            (t ,(delete :no-case 
               `(case ,e2 
                ,zero-case 
                (,ident ,e1) 
                (t (cond 
                   ((and (rationalp ,e1) 
                         (rationalp ,e2)) 
                    (,op ,e1 ,e2)) 
                   ((atom ,e2) 
                    (list ,e1 ,op-symbl ,e2)) 
                   (t (case 
                        (cadr ,e2) 
                      (,op-symbl (,func (,func ,e1 (car ,e2)) 
                                        (caddr ,e2))) 
                      (t  (list ,e1 ,op-symbl ,e2)))))))))))))) 

(defop apply+ + '+ 0 :no-case) 
(defop apply* * '* 1 ( 0  0 )) 

(defun simplify (expr) 
    (if (atom expr) 
       expr 
     (let ((e1 (simplify (car   expr))) 
           (e2 (simplify (caddr expr)))) 
       (case (cadr expr) 
             ('+ (apply+ e1 e2)) 
             ('* (apply* e1 e2)))))) 

(defun tt (N) (gc) (time (test N)))

(setq *expr* '(X * (((12 * 0) + (23 * 8)) + Y)))

(defun test (N)
    (COND ((ZEROP N) 0)
         (T (simplify *expr*) (test (1- N)))))
  
(mapc 'compile '(tt test defop simplify))



